Pascal Super Library/Pascal Super Library (CW International)(1997).bin/TABLES/MTABLE/CBTABLE.PAS

Pascal/Delphi Source File | 1994-04-01 | 15KB | 650 lines

unit CBTable;

interface

uses
  WinTypes,
  WinProcs,
  WinDos,
  Strings,
  MLBTypes,
  Table,
  WTools,
  CodeBase;

const
  TableDefinition: pChar = 'TABLEDEFINITION';

  t4num_str   =  'n';
  t4num_doub  =  'F';
  t4num_bcd   =  'N';
  t4date_doub =  'D';
  t4date_str  =  'd';
  t4str       =  'C';
  t4log       =  'L';

{ TABLEDEFINITION ---------------------------------------------------
     User defined resource containing information on CodeBase
     table fields.
     Resource structure:

     BEGIN
       N, COMMENT
       NAME_1, TYPE_1, LENGHT_1, DECIMALS_1,
       NAME_2, TYPE_2, LENGHT_2, DECIMALS_2,
       ...
       NAME_N, TYPE_N, LENGHT_N, DECIMALS_N
     END

     N           - INTEGER,
     COMMENT     - ASCIIZ,
     NAME_X      - ASCIIZ,
     TYPE_X      - CHAR,
     LENGHT_X    - INTEGER,
     DECIMALS_X  - INTEGER.

     Note, that #0 must be added to the end of each ASCIIZ string.
   ------------------------------------------------------------------ }

type
    tPathStr = array [0..fsPathName] of Char;
    tResStr  = array [0..50] of Char;

    pCBTable = ^tCBTable;
    tCBTable = object(tListTable)
      TableOpened  : Boolean;
      C4Code       : PC4CODE;
      CBTData      : PD4DATA;
      n_skip       : Word;
      FileName     : tPathStr;
      ResourceName : pChar;
      constructor  Init(AnItemsList: pItemsList; AC4Code: PC4CODE; AFileName: pChar; AResName: pChar);
      destructor   Done; virtual;
      function     AppendTable: Longint;
      function     AssignField(FieldData: PChar; FieldName: PChar): Boolean;
      function     BuildTable: Integer; virtual;
      function     CheckCBTableStruct: Boolean;
      function     CreateNewTable: Boolean;
      function     DeleteItem(ItemHandle: tItemHandle): Integer; virtual;
      function     GetCBTData: PD4DATA;
      function     GetField(FieldData, FieldName: PChar): Boolean;
      function     GetRecordCount: Longint; virtual;
      function     GetRecordField(RecNo: LongInt; Index: Word): PChar; virtual;
      function     GetRecordNo: Longint; virtual;
      function     GetRecordWidth: Word; virtual;
      function     LocateTable(RecNo: Longint): Boolean;
      function     NextRecord: Boolean; virtual;
      function     OpenCBTable: Integer;
      procedure    CloseCBTable;
      function     SkipRecord(dwRecno: Longint): Boolean; virtual;
      function     SwitchFileName(NewFileName: pChar): Integer;
      procedure    UnlockTable;
    end;

function MessageBoxEx(HWindow: HWnd; IDS_Text, IDS_Title: Word; Style: Word): Integer;

{$I CBTABLE.INC}
{$R CBTABLE.RES}

implementation

constructor tCBTable.Init(AnItemsList: pItemsList; AC4Code: PC4CODE; AFileName: pChar;
                          AResName: pChar);
begin
  inherited Init(AnItemsList);
  TableOpened := False;
  StrCopy(FileName, AFileName);
  ResourceName := AResName;
  C4Code := AC4Code;
  CBTData := nil;
  n_skip := 1;
end;

destructor tCBTable.Done;
begin
  if TableOpened then
    CloseCBTable;
  inherited Done;
end;

function tCBTable.AppendTable: Longint;
begin
  AppendTable := 0;
  if not TableOpened then Exit;
  if d4append_blank(CBTData) = 0 then
  begin
    UnlockTable;
    AppendTable := d4recno(CBTData);
  end;
end;

function tCBTable.AssignField(FieldData: PChar; FieldName: PChar): Boolean;
var
  FldType: Char;
  Field: PF4FIELD;
  D: Double;
  N: LongInt;
  Code: Integer;
  Buff: array [0..30] of Char;
begin
  { Assume failure }
  AssignField := False;

  if not TableOpened then
    Exit;

  { Check if field exist }
  Field := d4field(CBTData, FieldName);
  if Field = nil then
    Exit;

  { Get field type }
  FldType := Char(f4type(Field));

  case FldType of
    t4str:
      f4assign(Field, FieldData);
    t4date_doub:
      begin
        a4init(Buff, FieldData, 'DD/MM/YY');
        f4assign(Field, Buff);
      end;
    t4num_bcd,
    t4num_doub:
      begin
        if f4decimals(Field) = 0 then
        begin
          Val(FieldData, N, Code);
          if Code <> 0 then Exit;
          f4assign_long(Field, N);
        end
        else
        begin
          Val(FieldData, D, Code);
          if Code <> 0 then Exit;
          f4assign_double(Field, D);
        end;
      end;
    t4log:
        f4assign_char(Field, Integer(FieldData[0]));
  end;

  AssignField := True;
  UnlockTable;
end;

function tCBTable.BuildTable: Integer;
var
  tResult: Integer;
begin
  tResult := OpenCBTable;
  if tResult = tSuccess then
  begin
    tResult := inherited BuildTable;
    UnlockTable;
  end;
  BuildTable := tResult;
end;

function tCBTable.CheckCBTableStruct: Boolean;
var
  CurField: PF4FIELD;
  hResInfo, hResData: THandle;
  lpRes: PChar;
  NoOfFields, FldDec, FldLen, i: integer;
  FldType: Char;
  FWD: Byte;

procedure UnlockRes;
begin
  (*
   * Free user resource
   *)
  UnlockResource(hResData);
  FreeResource(hResData);
end;

begin
  CheckCBTableStruct := False;
  (*
   * Load user resource with file definition
   *)
  hResInfo := FindResource(hInstance, ResourceName, TableDefinition);
  if hResInfo = 0 then Exit;
  hResData := LoadResource(hInstance, hResInfo);
  lpRes := LockResource(hResData);

  (*
   * Get field number
   *)
  NoOfFields := Integer(lpRes^);

  (*
   * Check all fields in table
   *)
  Inc(lpRes, SizeOf(Integer) + StrLen(lpRes + SizeOf(Integer)) + SizeOf(Char));
  for i := 0 to NoOfFields - 1 do
  begin
    (*
     * Does field exist?
     *)
    CurField := d4field(CBTData, lpRes);
    if CurField = nil then
    begin
      UnlockRes;
      Exit;
    end;
    (*
     * Check field type
     *)
    Inc(lpRes, StrLen(lpRes) + 1);
    FldType := Char(lpRes^);
    if FldType <> Char(f4type(CurField)) then
    begin
      UnlockRes;
      Exit;
    end;
    (*
     * Check field width
     *)
    Inc(lpRes, SizeOf(Char));
    FldLen := Integer(lpRes^);
    if FldLen <> f4len(CurField) then
    begin
      UnlockRes;
      Exit;
    end;
    (*
     * Check field decimals
     *)
    Inc(lpRes, SizeOf(Integer));
    FldDec := Integer(lpRes^);
    if FldDec <> f4decimals(CurField) then
    begin
      UnlockRes;
      Exit;
    end;
    Inc(lpRes, SizeOf(Integer));
  end;
  (*
   * Free user resource
   *)
  UnlockRes;
  (*
   * Examination passed
   *)
  CheckCBTableStruct := True;
end;

procedure tCBTable.CloseCBTable;
begin
  if not TableOpened then
    Exit;
  d4flush_all(CBTData);
  d4close(CBTData);
  TableOpened := False;
end;

function tCBTable.CreateNewTable: Boolean;
type
  TFieldInfo = array [0..0] of F4FIELD_INFO;
  PFieldInfo = ^TFieldInfo;
var
  CBTableFields: PFieldInfo;
  hResInfo, hResData, hFields: THandle;
  lpRes: PChar;
  NoOfFields, i: Integer;
begin
  CreateNewTable := False;

  (*
   * Load user defined resource with file definitions
   *)
  hResInfo := FindResource(hInstance, ResourceName, TableDefinition);
  if hResInfo = 0 then Exit;
  hResData := LoadResource(hInstance, hResInfo);
  lpRes := LockResource(hResData);

  (*
   * Allocate memory for CodeBase file definition table
   *)
  NoOfFields := Integer(lpRes^);
  hFields := GlobalAlloc(GMEM_MOVEABLE or GMEM_ZEROINIT, Longint((NoOfFields + 1) * SizeOf(F4FIELD_INFO)));
  CBTableFields := PFieldInfo(GlobalLock(hFields));

  (*
   * Fill CodeBase file definition table
   *)
  Inc(lpRes, SizeOf(Integer) + StrLen(lpRes + SizeOf(Integer)) + SizeOf(Char));
  for i := 0 to (NoOfFields - 1) do
  begin
    CBTableFields^[i].fname := lpRes;
    Inc(lpRes, StrLen(lpRes) + 1);
    CBTableFields^[i].ftype := Char(lpRes^);
    Inc(lpRes, SizeOf(Char));
    CBTableFields^[i].flength := Integer(lpRes^);
    Inc(lpRes, SizeOf(Integer));
    CBTableFields^[i].fdecimals := Integer(lpRes^);
    Inc(lpRes, SizeOf(Integer));
  end;

   (*
    * Create empty database
    *)
   CBTData := d4create(C4Code, FileName, PF4FIELD_INFO(CBTableFields), nil);

   (*
    * If creation had success, close database
    *)
   TableOpened := CBTData <> nil;
   if TableOpened then
   begin
     CreateNewTable := True;
     d4close(CBTData);
     TableOpened := False;
   end;

   (*
    * Free allocated memory and resource
    *)
   GlobalUnlock(hFields);
   GlobalFree(hFields);
   UnlockResource(hResData);
   FreeResource(hResData);
end;

function tCBTable.DeleteItem(ItemHandle: tItemHandle): Integer;
var
  RecNo : longint;
  nRc   : Integer;
begin
  DeleteItem := -1;
  RecNo := -1;
  RecNo := GetItemRecNo(ItemHandle);
  if RecNo < 0 then Exit;
  if LocateTable(RecNo) then
  begin
    d4delete(CBTData);
    DeleteItem := inherited DeleteItem(ItemHandle);
  end;
end;

function tCBTable.GetCBTData: PD4DATA;
begin
  if not TableOpened then
    GetCBTData := nil
  else
    GetCBTData := CBTData;
end;

function tCBTable.GetField(FieldData, FieldName: PChar): Boolean;
var
  FldType: Char;
  Field: PF4FIELD;
begin
  { Assume failure }
  GetField := False;

  if not TableOpened then
    Exit;

  { Check if field exist }
  Field := d4field(CBTData, FieldName);
  if Field = nil then
    Exit;

  { Get field type }
  FldType := Char(f4type(Field));

  case FldType of
    t4str:
      StrCopy(FieldData, Trim(f4str(Field)));
    t4date_doub:
      a4format(Trim(f4str(Field)), FieldData, 'DD/MM/YY');
    t4num_bcd,
    t4num_doub:
      begin
        f4ncpy(Field, FieldData, f4len(Field));
        FieldData[f4len(Field)] := #0;
        Ltrim(FieldData);
      end;
    t4log:
      begin
        FieldData[0] := Char(f4char(Field));
        FieldData[1] := #0;
      end;
  end;

  GetField := True;
  UnlockTable;
end;

function tCBTable.GetRecordCount: Longint;
begin
  if TableOpened then
    GetRecordCount := d4reccount(CBTData)
  else
    GetRecordCount := 0;
end;

function tCBTable.GetRecordField(RecNo: LongInt; Index: Word): PChar;
var
  PRes, ExprRes: PChar;
  Res: array [0..MaxFieldWidth] of Char;
  Bmp: HBitmap;
begin
  GetRecordField := nil;

  if not TableOpened then
    Exit;

  case (ItemsList^.Items^[Index].ItemType) of
    ct_String:
      { String field }
      begin
        if ItemsList^.Items^[Index].FldName[0] = #0 then
           { Get field from GetStrField }
            StrCopy(Res, GetStrField(RecNo, Index))
        else
        begin
           { Get field from database }
           ExprRes := e4parse(CBTData, ItemsList^.Items^[Index].FldName);
           e4vary(ExprRes, @PRes);
           strcopy(Res, Trim(PRes));
           e4free(ExprRes);
        end;
      end;
    ct_Bitmap:
      { Bitmap field }
      begin
         { Get Bitmap from GetBmpField }
        Bmp := GetBmpField(RecNo, Index);
        move(Bmp, Res, SizeOf(HBitmap));
      end;
  end;

  GetRecordField := Res;
end;

function tCBTable.GetRecordNo: Longint;
begin
  if TableOpened then
    GetRecordNo := d4recno(CBTData)
  else
    GetRecordNo := -1;
end;

function tCBTable.GetRecordWidth: Word;
begin
  if TableOpened then
    GetRecordWidth := d4record_width(CBTData)
  else
    GetRecordWidth := 0;
end;

function TCBTable.LocateTable(RecNo: Longint): Boolean;
var
  nRc: Integer;
begin
  LocateTable := False;
  repeat
    nRc := d4go(CBTData, RecNo);
    if nRc = r4locked then
    begin
      nRc := MessageBoxEx(GetFocus, ids_CBTERR_LOCK,
                                    ids_CBTERROR, mb_RETRYCANCEL or mb_IconExclamation);
      if nRc = idCancel then
        Exit;
    end
    else
      if nRc <> 0 then
        Exit;
  until nRc = 0;
  LocateTable := True;
end;

function tCBTable.NextRecord: Boolean;
var
  nRc: Integer;
begin
  NextRecord := False;
  if not TableOpened then
    Exit;
  NextRecord := True;
  nRc := d4skip(CBTData, n_skip);
  if nRc = r4locked then
  begin
    { Insert message that there were locked records }
    repeat
      nRc := MessageBoxEx(GetFocus, ids_CBTERR_LOCK,
                                    ids_CBTERROR, mb_RETRYCANCEL or mb_IconExclamation);
      if nRc = idCancel then
      begin
        MessageBoxEx(GetFocus, ids_CBTERR_LOSEINFO,
                               ids_CBTERROR, mb_OK or mb_IconInformation);
        Inc(n_skip);
        nRc := 0;
      end
      else
        nRc := d4skip(CBTData, n_skip);
    until nRc = 0;
  end
  else
    if nRc = r4eof then
      NextRecord := False
    else
      n_skip := 1;
end;

function tCBTable.OpenCBTable: Integer;
var
  HFile: File;
  ExpName: tPathStr;
begin
  if TableOpened then
    Exit;

  TableOpened := False;

  { Assume failure }
  OpenCBTable := -1;

  FileSearch(ExpName, FileName, GetEnvVar('PATH'));

  if ExpName[0] = #0 then
    begin
      (*
       * File wasn't found
       *)
      if (MessageBoxEx(GetFocus, ids_CBTERR_FILENOTFOUND,
                                 ids_CBTERROR, mb_YESNO or mb_IconQuestion) = id_YES) then
        (*
         * Attempt to create new database
         *)
      begin
        if not CreateNewTable then
          begin
            (*
             * New database couldn't be created
             *)
            MessageBoxEx(GetFocus, ids_CBTERR_CREATENEW,
                                   ids_CBTFERROR, mb_OK or mb_IconHand);
            Exit;
          end
      end
      else
        Exit;
    end
  else
    (*
     * File found
     *)
    FileExpand(FileName, ExpName);

  CBTData := d4open(C4Code, FileName);

  if CBTData = nil then
  begin
    (*
     * Open Table fails
     *)
    MessageBoxEx(GetFocus, ids_CBTERR_OPENFILE,
                           ids_CBTFERROR, mb_OK or mb_IconHand);
    Exit;
  end;

  if not CheckCBTableStruct then
  begin
    (*
     * Check structure fails
     *)
    MessageBoxEx(GetFocus, ids_CBTERR_STRUCT,
                           ids_CBTFERROR, mb_OK or mb_IconHand);
    d4close(CBTData);
    Exit;
  end;

  d4top(CBTData);
  TableOpened := True;
  OpenCBTable := tSuccess;
end;

function tCBTable.SkipRecord(dwRecno: Longint): Boolean;
begin
  SkipRecord := True;
  if not TableOpened then
    Exit;
  if (d4deleted(CBTData) <> 0) then
  else
    SkipRecord := False;
end;

function tCBTable.SwitchFileName(NewFileName: pChar): Integer;
begin
  StrCopy(FileName, NewFileName);
  n_skip := 1;
end;

procedure tCBTable.UnlockTable;
begin
  if TableOpened then
    d4unlock_all(CBTData);
end;

{ MessageBoxEx ------------------------------------------------------
     Display message according to stringtable ids
  ------------------------------------------------------------------- }
function MessageBoxEx(HWindow: HWnd; IDS_Text, IDS_Title: Word; Style: Word): Integer;
const
  Title_Len = 50;
  Text_Len  = 200;
var
  mb_Title : array [0..Title_Len] of Char;
  mb_Text  : array [0..Text_Len] of Char;
begin
  LoadString(hInstance, IDS_Text, mb_Text, SizeOf(mb_Text));
  LoadString(hInstance, IDS_Title, mb_Title, SizeOf(mb_Title));
  MessageBoxEx := MessageBox(HWindow, mb_Text, mb_Title, Style);
end;

end.